home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Toolbox / Visual Basic Toolbox (P.I.E.)(1996).ISO / tpascal / bpvbx / models.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-08-31  |  7.2 KB  |  240 lines
  1. unit Models;
  2.  
  3. interface
  4. uses
  5.     Global,
  6.     Property,
  7.     Event,
  8.     Resource,
  9.     WinSys,
  10.     WinTypes,
  11.     WinProcs,
  12.     VBApi_,
  13.     Strings;
  14.  
  15. function CircleCtlProc(Control: HCtl; Wnd: HWnd;
  16.             Msg, wp: Word; lp: LongInt):LongInt; export;
  17.  
  18. {//---------------------------------------------------------------------------
  19. // Model struct
  20. //---------------------------------------------------------------------------
  21. // Define the control model (using the event and property structures).
  22. //---------------------------------------------------------------------------}
  23. const
  24.     ModelDefCtlName:     array[0..8] of Char = 'Circle'#0;         { default control name prefix}
  25.     ModelClassName:        array[0..14] of Char = 'Circle2'#0;{ Visual Basic class name}
  26.     ModelParentClassName:    array[0..8] of Char = #0;    { Parent window class if subclassed}
  27.     modelCircle: TMODEL = (
  28.         usVersion:        VB_VERSION;                            { VB version used by control}
  29.         fl:                0;                                     { Bitfield structure}
  30.         ctlproc:        TFarProc(@CircleCtlProc);            { The control proc.}
  31.         fsClassStyle:    cs_VRedraw or cs_HRedraw;            { window class style}
  32.         flWndStyle:        0;                                     { default window style}
  33.         cbCtlExtra:        sizeof(TCirc2);                        { # bytes alloc'd for HCTL structure}
  34.         idBmpPalette:    IDBMP_Circle;                            { BITMAP id for tool palette}
  35.         DefCtlName:     tOffset(@ModelDefCtlName);                 { default control name prefix}
  36.         ClassName:        tOffset(@ModelClassName);            { Visual Basic class name}
  37.         ParentClassName:    0;                                { Parent window class if subclassed}
  38.         proplist:        ofs(Circle_Properties);                { Property list}
  39.         eventlist:        ofs(Circle_Events);                 { Event list}
  40.         nDefProp:         ord(IPROP_Circle_BackColor);                { index of default property}
  41.         nDefEvent:        ord(Event_Circle_ClickIn);                { index of default event}
  42.         nValueProp:        ord(IProp_Circle_Shape));            { default value }
  43.  
  44. implementation
  45.  
  46. procedure PaintCircle(Control: hCtl; Wnd: HWnd; hDcIn: hDc);
  47. var
  48.     lpCirc:    pCirc2;
  49.     lpRect: tRect;
  50.     hBr,
  51.     hBrOld:    HBrush;            { defined in windows}
  52. begin
  53.     hBrOld := 0;
  54.     lpCirc := VBDerefControl(Control);
  55.     lpRect := lpCirc^.RectDrawInto;
  56.     GetClientRect(Wnd, lpRect);
  57.     hBr := SendMessage(GetParent(Wnd), WM_CTLCOLOR, hDcIn, MAKELong(Wnd, 0));
  58.     if (hBr <> 0) then
  59.         hbrOld := SelectObject(hDcIn, hBr);
  60.     Ellipse(hdcin, lpRect.left, lpRect.top, lpRect.right, lpRect.bottom);
  61.     if hBrOld <> 0 then
  62.         SelectObject(hDcIn, hBrOld);
  63. end;
  64.  
  65. {---------------------------------------------------------------------------
  66.  Paint the circle in the FlashColor.
  67. ---------------------------------------------------------------------------}
  68. procedure FlashCircle(Control: hctl; hDcIn: hDc);
  69. var
  70.     hbr,
  71.     hbrOld:    hBrush;
  72.     lpCirc: pCirc2;
  73.     lpRect:    tRect;
  74. begin
  75.     hbrOld := 0;
  76.     lpcirc := VBDerefControl(Control);
  77.     lpRect := lpCirc^.rectDrawInto;
  78.     hbr := CreateSolidBrush(lpcirc^.FlashColor);
  79.     if (hbr <> 0 ) then
  80.         hbrOld := SelectObject(hDcIn, hbr);
  81.     Ellipse(hDcIn, lpRect.left, lpRect.top, lpRect.right, lpRect.bottom);
  82.     if (hbr <> 0) then begin
  83.         SelectObject(hDcIn, hbrOld);
  84.         DeleteObject(hbr);
  85.     end;
  86. end;
  87.  
  88.  
  89. {---------------------------------------------------------------------------
  90.  Use the hwnd's client size to determine the bounding rectangle for the
  91.  circle.  If CircleShape is TRUE, then we need to calculate a square
  92.  centered in lpRect.
  93. ---------------------------------------------------------------------------}
  94. procedure RecalcArea(Control: hctl; Wnd: hwnd);
  95. var
  96.     lpCirc: pCirc2;
  97.     lpRect:    tRect;
  98. begin
  99.     lpcirc := VBDerefControl(Control);
  100.     lpRect := lpCirc^.rectDrawInto;
  101.  
  102.     GetClientRect(Wnd, lpRect);
  103.     if (lpCirc^.CircleShape = 0) then exit;
  104.     if (lpRect.right > lpRect.bottom) then begin
  105.         lpRect.left  := (lpRect.right - lpRect.bottom) div 2;
  106.         lpRect.right := lpRect.left + lpRect.bottom;
  107.     end else if (lpRect.bottom > lpRect.right) then begin
  108.         lpRect.top    := (lpRect.bottom - lpRect.right) div 2;
  109.         lpRect.bottom := lpRect.top + lpRect.right;
  110.     end;
  111. end;
  112.  
  113.  
  114. {--------------------------------------------------------------------------
  115.  Return TRUE if the given coordinates are inside of the circle.
  116. ---------------------------------------------------------------------------}
  117. function InCircle(Control: hctl; xcoord, ycoord: integer): boolean;
  118. var
  119.     lpCirc: pCirc2;
  120.     lpRect:    tRect;
  121.     a, b:    longInt;
  122.     x, y:    longInt;
  123.     c, d:    longInt;
  124. begin
  125.     lpcirc := VBDerefControl(Control);
  126.     lpRect := lpCirc^.rectDrawInto;
  127.     a := (lpRect.right    - lpRect.left) div 2;
  128.     b := (lpRect.bottom - lpRect.top) div 2;
  129.     x := xcoord - (lpRect.left + lpRect.right)  div 2;
  130.     y := ycoord - (lpRect.top  + lpRect.bottom) div 2;
  131.     c := (a * a);
  132.     if c <> 0 then
  133.         c := ((x * x) div c)
  134.     else
  135.         c := (x * x);
  136.     d := (b * b);
  137.     if d <> 0 then
  138.         d := (y * y) div d
  139.     else
  140.         d := (y * y);
  141.     InCircle := (c + d <= 1);
  142. end;
  143.  
  144.  
  145. {---------------------------------------------------------------------------
  146.  TYPEDEF for parameters to the ClickIn event.
  147. ---------------------------------------------------------------------------}
  148. Type
  149.     tagCLICKINPARMS = record
  150. {    float far *Y;} Y:   pointer;
  151. {    float far *X;} X:    pointer;
  152. {    LPVOID     Index;}Index:    LPVoid;
  153.     end;
  154.  
  155.  
  156. {--------------------------------------------------------------------------
  157.  Fire the ClickIn event, passing the x,y coords of the click.
  158. ---------------------------------------------------------------------------}
  159. procedure FireClickIn(Control: hctl; x, y: integer);
  160. var
  161.     params:    tagClickInParms;
  162.     xTwips,
  163.     yTwips:    LongInt;
  164. begin
  165.     xTwips := VBXPixelsToTwips(x);
  166.     yTwips := VBYPixelsToTwips(y);
  167.     params.X := @xTwips;
  168.     params.Y := @yTwips;
  169.     VBFireEvent(Control, ord(EVENT_CIRCLE_CLICKIN), @params);
  170. end;
  171.  
  172.  
  173. {---------------------------------------------------------------------------
  174.  Fire the ClickOut event.
  175. ---------------------------------------------------------------------------}
  176. procedure FireClickOut(Control: hctl);
  177. begin
  178.     VBFireEvent(Control, ord(EVENT_CIRCLE_CLICKOUT), NIL);
  179. end;
  180.  
  181. function CircleCtlProc(Control: HCtl; Wnd: HWnd;
  182.             Msg, wp: Word; lp: LongInt):LongInt;
  183. var
  184.     ps:        tPaintStruct;
  185.     LpCirc:    pCirc2;
  186.     hDcHold:    hDc;
  187. begin
  188.  
  189.     case Msg of
  190.         WM_NCCREATE:    begin
  191.             LpCirc := VBDerefControl(Control);
  192.             LpCirc^.CircleShape := 0;
  193.             lpCirc^.FlashColor := 128;
  194.             VBSetControlProperty(Control, ord(IPROP_Circle_BACKCOLOR), 255);
  195.         end;
  196.         WM_LBUTTONDOWN,
  197.         WM_LBUTTONDBLCLK:
  198.             if (InCircle(Control, lp, HiWord(lp))) then begin
  199.                 hDcHold := GetDC(Wnd);
  200.                 FlashCircle(Control, hDcHold);
  201.                 ReleaseDC(Wnd, hDcHold);
  202.                 FireClickIn(Control, lp, HiWord(lp));
  203.             end else
  204.                 FireClickOut(Control);
  205.         WM_LBUTTONUP:
  206.             if (InCircle(Control, lp, HIWORD(lp))) then begin
  207.                 hDcHold := GetDC(Wnd);
  208.                 PaintCircle(Control, Wnd, hDcHold);
  209.                 ReleaseDC(Wnd, hDcHold);
  210.             end;
  211.  
  212.         WM_PAINT:
  213.             if (wP <> 0) then
  214.                 PaintCircle(Control, Wnd, wP)
  215.             else begin
  216.                 BeginPaint(Wnd, ps);
  217.                 paintCircle(Control, Wnd, ps.hdc);
  218.                 EndPaint(Wnd, ps);
  219.             end;
  220.         WM_SIZE:    RecalcArea(Control, Wnd);
  221.         VBM_SETPROPERTY:
  222.             case wP of
  223.                 ord(IPROP_Circle_Shape): begin
  224.                     lpCirc := VBDerefControl(Control);
  225.                     lpCirc^.CircleShape := lp;
  226.                     RecalcArea(Control, Wnd);
  227.                     InvalidateRect(Wnd, nil, true);
  228.                     CircleCtlProc := 0;
  229.                     exit;
  230.                 end;
  231.             end;
  232.     end;
  233.  
  234.     {// Default processing:}
  235.     CircleCtlProc := VBDefControlProc(Control, Wnd, Msg, wP, lP);
  236.  
  237. end;
  238.  
  239. end.
  240.